home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Wonky Flux Batch 2019 02
/
Wonky_Flux_Batch_2019-02.zip
/
Wonky Flux Batch 2019-02
/
071 - EXFER 4.1 4.2.dsk
/
EXFER.SYS.S
< prev
next >
Wrap
Text File
|
2019-02-17
|
23KB
|
618 lines
; ****************************
;
; EXfer:
; The Extended Transfer Module
;
; This program is for use on
; the ProDOS version of GBBS
; "Pro" 1.2 and "Pro" 1.3.
;
; Written by: Mike Golaszewski
; (C)1986, All Rights Reserved
;
; ****************************
; THIS IS NOT FREEWARE
; system segment, version 4.0
; created 08/23/86 - modified 11/09/87
; Special thanks to Mark Roberts for providing much of the ideas and concepts
; found in EXfer, and for vigorously testing the program; Jerry Cline for his
; ideas and suggestions; Kieth Christian for his support; Lance Taylor-Warren
; for providing GBBS 1.3 information; and especially Greg Schaefer ("Gee Ess")
; for all his input.
; define link in labels
public add
public create
public external
public sort
public credit
; external commands
; ~~~~~~~~~~~~~~~~~
; get & parse command string
external
on nocar goto terminate
input @2 "External: " i$
if i$="?" goto ex.mnu
a=instr(" ",i$):if a=0 goto ret
x$=left$(i$,a-1):b=instr(",",i$)
if not(b) then y$=mid$(i$,a+1):z$="":goto ext.1
y$=mid$(i$,a+1,b-1):z$=mid$(i$,b+1)
ext.1
if x$="D" or x$="DUMP" goto dump
if x$="H" or x$="HELP" goto hedit
if x$="S" or x$="SWAP" goto swap
if x$="P" or x$="PURGE" goto purge
if x$="R" or x$="RESET" goto reset
if x$="Z" or x$="ZAP" goto zap
print \"XT:"chr$(7)" Command not recognized":goto ret
ex.mnu
print'
DUMP x dump directory to printer
HELP command edit help on command
SWAP x1,x2 swap two libraries
PURGE x purge library
RESET x reset library
ZAP x zero out library'
print:goto external
; :::::::::::::::::::::::::::::::::::::
; external command functions begin here
; :::::::::::::::::::::::::::::::::::::
; swap two libraries
; ~~~~~~~~~~~~~~~~~~
swap
b=val(y$):c=val(z$)
if (b<1 or b>255) or (c<1 or c>255) or (b=c) goto ret
; commence swapping
i$="R A1:XV."+str$(b)+",A1:X.TEMP"
use "a:xdos",i$:i$="R A1:XV."+str$(c)+",A1:XV."+str$(b)
use "a:xdos",i$:i$="R A1:X.TEMP,A1:XV."+str$(c)
use "a:xdos",i$:i$="R A1:DV."+str$(b)+",A1:X.TEMP"
use "a:xdos",i$:i$="R A1:DV."+str$(c)+",A1:DV."+str$(b)
use "a:xdos",i$:i$="R A1:X.TEMP,A1:DV."+str$(c)
use "a:xdos",i$
; update the bit map
open #1,"a1:xt.bitmap":read #1,ed+1,255:close
x=peek(ed+b):y=peek(ed+c):poke ed+b,y:poke ed+c,x
open #1,"a1:xt.bitmap":write #1,ed+1,255:close
; switch names in volume file
open #1,"a1:xt.volumes":position #1,32,b
input #1,x$:position #1,32,c:input #1,y$
position #1,32,b:print #1,y$:position #1,32,c
print #1,x$:close:print \"XT: Libraries swapped..."
push ret:goto log
; edit entry in the help file
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~
hedit
x=instr(y$,"CDFHIKLMNRSTVX?B"):if not(x) goto ret
ready "a1:hlp.exfer":input #msg(x),a,x$:input #6,x$
edit(0):copy #6,#8:print '
Edit help message: 'edit(3)' cols, [4K] max
[DONE] when finished, [.H] for help'
edit(1):if not(edit(2)) goto ret
print \"XT: Enter command line [ie: D)irectory]"
input @3 " :>" i$:if i$="" goto ret:else kill #msg(x)
print #msg(x),x,y$:print #6,i$:copy #8,#6:msg(x)=1
update:ready d2$:goto ret
; purge files from a directory
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
purge
x=val(y$):ob=bb:bb=x:gosub log:if bf$="" then bb=ob:push ret:goto log
print \"XT: ["bn$"]"\:input @2 "XT: Purge this volume ? " i$
i$=left$(i$,1):if i$<>"Y" then bb=ob:push ret:goto log
input @0 \"XT: Remove files from disk ? " z$
open #1,d1$:print \"XT: "byte(4)" entries; purging #002";
for l=1 to byte(4):print chr$(8,3);right$("00"+str$(l),3);
position #1,32,l+1:input #1,i$:if i$="" next:goto purge.1
if z$="Y" gosub name:f$=bf$+f$:kill f$
position #1,32,l+1:print #1,chr$(13):next
purge.1
close:print chr$(8,3)"---":byte(4)=2:open #1,d1$
print #1,bn$:print #1,bf$:write #1,ram2,9:close
ready "g:mail":kill d2$:print '
XT: Creating new description file...':gosub make.msg:ready d2$
bb=ob:push ret:goto log
; erase trashed file information
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
reset
x=val(y$):ob=bb:bb=x:gosub log:if bf$="" then ob=bb:push ret:goto log
print \"XT: ["bn$"]"\:input @2 "XT: Reset file information ? " i$
i$=left$(i$,1):if i$<>"Y" then bb=ob:push ret:goto log
open #1,d1$:print \"XT: "byte(4)" entries; erasing #002";
for l=1 to byte(4):print chr$(8,3);right$("00"+str$(l),3);
position #1,32,l+1:input #1,i$:if i$="" next:goto reset.1
input #1,x$:read #1,ram2+9,10:byte(14)=0:position #1,32,l+1
print #1,i$:print #1,x$:write #1,ram2+9,10:next
reset.1
close:print chr$(8,3)"---":ready "g:mail":kill d2$:print '
XT: Creating new description file...':gosub make.msg:ready d2$
bb=ob:push ret:goto log
; send a directory to the printer
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dump
x=val(y$):ob=bb:bb=x:gosub log:if bf$="" then ob=bb:push ret:goto log
y=5:gosub dir.h:use "a1:xtyp",bf$:open #1,d1$:for l=1 to byte(4)
position #1,32,l+1:input #1,i$:input #1,ty$:position #1,32,l+1,20
read #1,ram2+9,10:if i$="" goto dump.1:else na$=i$:gosub name
a$=bf$+f$:f$=na$:gosub dir.e:print #5
dump.1
next:close
; print
x=peek(865)+peek(866)*256:y=peek(867)+peek(868)*256:z=x-y
print #5,\"Kbytes Free: "left$(str$(z)+chr$(32,3),4);
print #5," "right$(" Kbytes Used: "+str$(y),19);
print #5," Total Kbytes: "x:print #5,chr$(12)
bb=ob:push ret:goto log
; Zap a library out of existance
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
zap
x=val(y$):i$="d a1:xv."+str$(x)
use "a:dos",i$:i$=d a1:dv."+str$(x)
use a:xdos",i$
open #1,"a1:xt.bitmap":read #1,ed+1,255:close
poke ed+x,255
open #1,"a1:xt.bitmap":write #1,ed+1,255:close
open #1,"a1:xt,volumes":position #1,32,x
print #1:close
goto ret
; :::::::::::::::::::::::::::::::::::
; external commands routines end here
; :::::::::::::::::::::::::::::::::::
; edit a user's credit status
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~
credit
input @2 "Credit record of user #" i$:if i$="" goto ret
a=val(i$):open #1,"a:users":position #1,128,a:input #1,i$,x$:close
if i$="" print '
XT: No such user...':goto ret
print '
XT: 'i$' 'x$:open #1,"a1:xt.users":position #1,4,a:read #1,ram2,4:close
x=byte(2)+byte(3)*256:if not(byte(1)) input '
XT: This user does not yet have an
EXfer credit account. Set one
up now [Y/N] ? ' i$:if i$="Y" then byte(1)=1:x=250
print '
XT: This user has 'x' credits.'
input @2 '
XT: Enter new value or press [RETURN]
to exit: ' i$:if i$="" goto credit.1
x=val(i$):if x<0 then x=0
credit.1
byte(2)=x mod 256:byte(3)=x/256:open #1,"a1:xt.users"
position #1,4,a:write #1,ram2,4:close:print '
XT: Credit status updated...':goto ret
; optimize directory
; ~~~~~~~~~~~~~~~~~~
sort
on nocar goto terminate
input @2 "Sort by N)ame or T)ype ? " i$:if i$="" goto ret
print \"XT: "byte(4)" entries; sorting #002";:open #1,d1$:x=2
; use the GS SBS algorithm
sort.1
position #1,32,x:input #1,a$:input #1,y$
position #1,32,x,20:read #1,ram2+9,10
position #1,32,x+1:input #1,b$:input #1,z$
if b$="" goto sort.3:else if a$="" goto sort.2
if (i$<>"T") and (a$<=b$) goto sort.3
if (i$="T") and (y$<=z$) goto sort.3
; swap entries around
sort.2
position #1,32,x+1,20:read #1,ram2+20,10
position #1,32,x:print #1,b$:print #1,z$:write #1,ram2+20,10
position #1,32,x+1:print #1,a$:print #1,y$:write #1,ram2+9,10
if x>2 then x=x-1:print chr$(8,3);right$("00"+str$(x),3);
goto sort.1
sort.3
x=x+1:print chr$(8,3);right$("00"+str$(x),3);
if x<=byte(4) goto sort.1:else close:print chr$(8,3)"---"
goto ret
; add a file to the directory
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~
; get filename to add
add
on nocar goto terminate
if nb=255 goto dfull
d=0:input @2 "Add: " i$:if i$="" goto ret
na$=left$(i$+chr$(32,14),15):i$=na$:gosub read
if l=0 goto add.1
; see if existing directory entry is to be replaced
input @2 \"XT: Replace existing entry ? " x$
if x$<>"Y" goto ret:else nb=l:d=byte(14)
; file doesn't exist on ProDOS volume
add.1
i$=na$:gosub name:f$=bf$+f$:gosub chkfil:close
if not(a) goto add.2:else print \"XT: "f$" doesn't exist on "bf$
input @2 " Add anyways ? " i$:if i$<>"Y" goto ret
; compute some file info
add.2
gosub dtype:gosub size:gosub sfile:byte(9)=255:byte(14)=0
; ask for a description
on nocar goto add.3
if d print '
XT: Do you want to change the existing
file information ? ';:else print '
XT: Would you like to enter a short
description of this file ? ';
input @2 i$:i$=left$(i$,1):if i$<>"Y" goto add.3
edit(0):if d input #msg(d),a:input #6,x$\y$\z$:copy #6,#8
gosub edesc:if not(edit(2)) goto add.3
if d then byte(14)=d:kill #msg(d):update:goto add.i
a=1
add.f
if msg(a) then a=a+1:else d=a:goto add.i
if a>msg(0) then d=a:goto add.i
goto add.f
add.i
kill #msg(d):print #msg(d),un:print #6,na$
print #6,"Uploader: "a1$" "a2$" [#"un"]"
print #6,"Uploaded: "date$" "time$\:copy #8,#6
msg(d)=255:update
add.3
if d then byte(14)=d
d=1:if nb<>byte(4) goto write:else goto update
; routine to create libraries
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~
; set defaults for new directory
create
if bf$<>"" goto create.1
bn$="New directory"+chr$(32,17):bf$="D: "
byte(0)=1:byte(1)=1:byte(2)=1:byte(3)=0
byte(4)=2:byte(5)=0:byte(6)=0:zz$="x"
; print info to the screen
create.1
on nocar goto terminate
if byte(7)>20 then byte(7)=20
if byte(8)>20 then byte(8)=20
if byte(0)>byte(1) then byte(1)=byte(0)
if byte(0)>byte(2) then byte(2)=byte(0)
print \\screen$"XT: Library #"right$("00"+str$(bb),3)"..."\
print "1-Name...."bn$\"2-Drive..."bf$\
print "3-Librarian: ";:if not(b1) print "None":else print b1
print \"4-Access level: "byte(0)\"5-Upload level: "byte(2)
print "6-D/load level: "byte(1)\
print "7-Auto-validate files ? ";:if not(byte(3)) print "No"
if byte(3) print "Yes"
print \"8-Uploads: 1K * "byte(7)" credits"
print "9-D/loads: 1K * "byte(8)" credits"
input @2 \"Change which [1-9] ? " i$:if i$="" goto create.2
; change an option
if i$="1" input @3 \"Name: " i$:bn$=left$(i$+chr$(32,29),30):i$=""
if (i$="2") and (info(5)) input @2 \"Drive: " i$:bf$=left$(i$+chr$(32,3),4)
if i$="3" input \"Librarian's user #: " x$:b1=val(x$)
if i$="3" then byte(6)=b1/256:byte(5)=b1 mod 256:i$=""
if i$="4" input \"Access level: " i$:byte(0)=val(i$):i$=""
if i$="5" input \"Upload level: " i$:byte(2)=val(i$):i$=""
if i$="6" input \"D/load level: " i$:byte(1)=val(i$):i$=""
if i$="8" input \"Upload multiplier: " i$:um=val(i$):byte(7)=um:i$=""
if i$="9" input \"D/load multiplier: " i$:dm=val(i$):byte(8)=dm:i$=""
if i$<>"7" goto create.1
if byte(3)=0 then byte(3)=255:goto create.1
byte(3)=0:goto create.1
; see if the directory is to be saved
create.2
input \"XT: Save this ? " i$
if i$<>"Y" bb=ob:gosub log:push ret:goto getslt
; update the bit-map
d=1:print \"XT: Updating volume bit-map..."
open #1,"a1:xt.bitmap":read #1,ed+1,255:close
poke ed+bb,byte(0):open #1,"a1:xt.bitmap"
write #1,ed+1,255:close:open #1,"a1:xt.volumes"
position #1,32,bb:print #1,bn$:close
; save the stuff
z$="a1:xv."+str$(bb):if zz$="x" create d1$
open #1,z$:print #1,bn$:print #1,bf$:write #1,ram2,9
close
if zz$<>"x" gosub log:push ret:goto getslt
; make a new message file for this library
zz$="":print \"XT: Making description file..."
gosub make.msg:gosub log:push ret:goto getslt
; return to main module
; ~~~~~~~~~~~~~~~~~~~~~
ret
link "a:exfer.seg","prompt"
; loss of carrier
; ~~~~~~~~~~~~~~~
terminate
byte=ram2:byte(0)=xm+(pt*8):byte(1)=1:byte(2)=cr mod 256:byte(3)=cr/256
open #1,"a1:xt.users":position #1,4,un:write #1,ram2,4:close
poke ram2,v:when$=ram+20:if v=0 then byte=ram+29:goto term.1
byte=ram+37:nibble(3)=dl/256:byte(3)=dl mod 256
nibble(4)=ul/256:byte(4)=ul mod 256
term.1
clear:recall "a:variables":kill "a:variables"
if x=13 then ul=byte(4)+nibble(4)*256:dl=byte(3)+nibble(3)*256
link "a:main.seg","termin2"
; ::::::::::::::::::::
; disk I/O subroutines
; ::::::::::::::::::::
; get an empty slot
; ~~~~~~~~~~~~~~~~~
getslt
nb=0:open #1,d1$:for l=1 to byte(4)
position #1,32,l+1:input #1,i$
if (i$="") and (nb=0) then nb=l:l=byte(4)
next:close:if not(nb) then nb=byte(4)
return
; log to a volume
; ~~~~~~~~~~~~~~~
log
byte=ram2:fill ram2,64,0:bf$="":z$="a1:xv."+str$(bb)
open #1,z$:input #1,bn$:input #1,bf$
read #1,ram2,9:close:b1=byte(5)+byte(6)*256
b2=1:if byte(0) then b2=flag(byte(0))
b3=1:if byte(1) then b3=flag(byte(1))
b4=1:if byte(2) then b4=flag(byte(2))
um=byte(7):dm=byte(8):lb=(b1=un)
if info(5) then lb=1:b2=1:b3=1:b4=1
d1$="a1:xv."+str$(bb):d2$="a1:dv."+str$(bb)
if bf$ then ready d2$:bf$=left$(bf$,instr(":",bf$))
return
; make a description file
; ~~~~~~~~~~~~~~~~~~~~~~~
make.msg
y=256:z=256:f$="a1:dv."+str$(bb)
y=(y/128)*128:z=(z/128)*128:l=(y/32)+(z/128)
fill ram2,64,0:byte(0)=z/128:byte(1)=y/32
create f$:open #1,f$:write #1,ram2,8
fill ram2,64,0:for x=1 to l:write #1,ram2,64
write #1,ram2,64:next:close:x=6:goto type
; update "number of entries" counter
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
update
byte(4)=byte(4)+1:open #1,d1$:print #1,bn$
print #1,bf$:write #1,ram2,9:close
; write a directory entry
; ~~~~~~~~~~~~~~~~~~~~~~~
write
open #1,d1$:position #1,32,nb+1:print #1,na$
print #1,ty$:write #1,ram2+9,10:close
push ret:goto getslt
; read a directory entry
; ~~~~~~~~~~~~~~~~~~~~~~
read
open #1,d1$:for l=1 to byte(4)
position #1,32,l+1:input #1,f$
if instr(i$,f$)=1 then p=l:l=byte(4):next:l=p:goto read.1
next:close:l=0:return
read.1
input #1,ty$:read #1,ram2+9,10:close
return
; read a file by slot #
; ~~~~~~~~~~~~~~~~~~~~~
nread
if left$(i$,1)="#" then i$=mid$(i$,2)
l=val(i$):if (l<1) or (l>253) then l=0:return
open #1,d1$:position #1,32,l
input #1,f$:if f$="" close #1:l=0:return
input #1,ty$:read #1,ram2+9,10:close #1
i$=f$:if pt=2 return:else print \"XT: [#"l"]: "i$:return
; show a directory header
; ~~~~~~~~~~~~~~~~~~~~~~~
dir.h
print #y,right$("00"+str$(bb),3)": "bn$;
print #y," Librarian: "right$("00"+str$(b1),3)
print #y,'
# Filename Typ I Size Uploaded Uploader Downloaded Miscellaneous'\
return
; display an entry
dir.e
print #y,right$("00"+str$(l+1),3)" "f$" "ty$" ";
if byte(14) print #y,"Y ";:else print #y,"N ";
x=byte(10)+byte(11)*256:print #y,right$(" "+str$(x),4)" ";
b$=when$:if (not(byte(9))) print #y,"VALIDATE";:else print #y,b$;
z=byte(18):x=byte(12)+byte(13)*256
print #y," User " right$("00"+str$(x),3);
print #y," "right$("00"+str$(z),3)" times "a$;
return
; find the type of a file
; ~~~~~~~~~~~~~~~~~~~~~~~
dtype
use "a1:xtyp",f$:x=peek(ram2+32)
x$="???0TXT4PDA5BIN6ADB25AWP26ASP27SRC176OBJ177LIB178S16179RTL180EXE181"
x$=x$+"STR182RIF183NDA184CDA185SET186PNT192PIC193ANI194FNT200PAS239CMD240"
x$=x$+"COM245P16249BAS252VAR253REL254SYS255"
ty$="":y=instr(str$(x),x$):if y then ty$=mid$(x$,y-3,3):goto id
ty$="$"+chr$(48+x/16+((x/16)>9)*7)+chr$(48+x mod 16+((x mod 16)>9)*7)
; detect Macbinary or Binary ][ formats
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
id
x$=right$(f$,4)
if (x$=".BNY") or (x$=".BQY") or (x$=".SQZ") then ty$=right$(x$,3):return
open #1,f$:read #1,ram2+32,3:close #1
if (byte(32)=10) and (byte(33)=71) and (byte(34)=76) then ty$="BNY"
if (ty$="???") and ((byte(32)=0) and (byte(33))) then ty$="MAC"
return
; set a file type
; ~~~~~~~~~~~~~~~
type
use "a1:xtyp",f$,x:return
; return size of F$ in A
; ~~~~~~~~~~~~~~~~~~~~~~
size
open #1,f$:a=size(1)/2+1:close:return
; see if file exists
; ~~~~~~~~~~~~~~~~~~
chkfil
open #1,f$:a=mark(1):return
; :::::::::::::::::::
; special subroutines
; :::::::::::::::::::
; get a file description
; ~~~~~~~~~~~~~~~~~~~~~~
edesc
print '
Enter description: 'edit(3)' cols, [4K] max
[DONE] when finished, [.H] for help'
edit(1):return
; convert to a valid ProDOS name
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; shorten I$ to directory length
name
if len(i$)>15 then i$=left$(i$,15)
i$=i$+chr$(1)
; make sure the first char is a letter
name.0
a=asc(left$(i$,1)):if a=1 pop:goto ret
if (a>64) and (a<91) then i$=left$(i$,len(i$)-1):goto name.1
if (a>96) and (a<123) then i$=left$(i$,len(i$)-1):goto name.1
i$=mid$(i$,2):goto name.0
; remove symbols from the name
name.1
f$="":for x=1 to len(i$):a=asc(mid$(i$,x,1))
if (a>64) and (a<91) goto name.2
if (a>96) and (a<123) goto name.2
if (a>47) and (a<58) goto name.2
if a=46 goto name.2:else goto name.3
; add a valid character
name.2
f$=f$+chr$(a)
; if we dont have a name, return to the prompt
name.3
next:if f$="" pop:return
if len(f$)>15 then f$=left$(f$,15)
return
; set file information
; ~~~~~~~~~~~~~~~~~~~~
sfile
byte(9)=byte(3):byte(10)=a mod 256:byte(11)=a/256
byte(12)=un mod 256:byte(13)=un/256:byte(18)=0
when$="x":if lb then byte(9)=255
return
; ::::::::::::::
; error messages
; ::::::::::::::
nfile
print \\"XT:"chr$(7)" No such file...":goto ret
dfull
print \\"XT:"chr$(7)" Directory full...":goto ret